Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/tp_dmx20.zip/DMXDFILE.PAS

Pascal/Delphi Source File | 1990-01-15 | 8KB | 290 lines

Unit DMXdFILE;

{$V-,I- }

(*
  There are two DMX objects available for access to dBASE files:

       dBMXwindow has been written to edit small files in memory,
       with a predefined number of records.

       dBrowser is for larger files.  Its DataAt function has been rewritten
       in order to get records from the disk, one-at-a-time.
       An artificially high number of bytes should be passed to OpenBuffer
       so that DMX will allow a large number of records.

       The file DBENTRY.PAS demonstrates how these procedures are used.
 *)

interface

uses   Dos, Crt, DMX2, DMX_FILE;


type
       dBMXwindow   = object (Dwindow)
                        fheader  : array [0..MaxFields] of headertype;

                        procedure dBASEopen (var Data; Size : longint; var F );
                        procedure dBASEwrite(var Data;  var F );

                        procedure dBASEnew;  virtual;
                      end;


       dBrowser     = object (dBMXwindow)
                        dbfrecord  : array [0..255] of char;
                        workfile   : dbfile;

                        procedure EvaluateRecord (RecNum :longint; Line :word);
                                  virtual;
                        function  DataAt (recnum : longint) : pointer;
                                  virtual;
                        procedure ZeroizeRecord (var Data );
                                  virtual;

                        procedure dBASEinit (Filename : pathstr);
                        procedure dBASEclose;
                      end;


implementation


  { ─────────────────────────────────────────────────────────────────────── }


procedure dBMXwindow.dBASEnew;
{ virtual procedure for new setup }
var  i,j,k,l,m  : word;
     AStr       : string;
begin
  i := 0;
  If dataleader > 1 then
    begin
    InitializeField (fheader [1], '000', 'C', pred (dataleader), 0);
    Inc (i);
    end;

  l := totalfields;
  If dataleader  > 1 then Inc (l);

  If datatrailer > 0 then
    begin
    InitializeField (fheader [succ (totalfields)], 'XXX', 'C', datatrailer, 0);
    Inc (l);
    end;

  InitializeHeader (fheader, l, recordsize, False);
  FillChar (fheader [succ (l)], 1, #13);

  For j := 1 to totalfields do
    begin
    AStr := copy (title,
                  screentab [j],
                  (screentab [succ (j)])-(screentab [j])-1);
    While AStr [length (AStr)] = ' ' do Dec (AStr [0]);
    While (length (AStr) > 0) and (AStr [1] = ' ') do Delete (AStr,1,1);
    If AStr = '' then
      Str (j:0,AStr)
     else
      begin
      If length (AStr) > 11 then AStr [0] := #11;
      For m := 1 to length (AStr) do AStr [m] := upcase (AStr [m]);
      end;
    If upcase (datatype [j]) = 'N' then
      begin
      l := 0;
      k := screentab [j];
      While (k < screentab [succ (j)] - 1) and (dataformat [k] <> '.') do
        Inc (k);
      Inc (k);
      While (k < screentab [succ (j)] - 1) do
        begin
        If upcase (dataformat [k]) = 'N' then Inc (l);
        Inc (k);
        end;
      InitializeField (fheader [i + j],  AStr, 'N', datatab [i + j], l);
      end
     else
      begin
      InitializeField (fheader [i + j],  AStr, 'C', datatab [i + j], 0);
      end;
    end;
end;  { dBASEnew }


  { ─────────────────────────────────────────────────────────────────────── }


procedure dBMXwindow.dBASEopen (var Data;  Size : longint;  var F );
var  i : word;
begin
  If Size > 0 then FillChar (Data, Size, ' ');
  If dataleader = 0 then
    AdjustRecSize (1,0,0);
       { This accounts for the one byte in front of each record,
         which is expected by dBASE.

         The second parameter would indicate how many undisplayed bytes
         there may be at the end of each record.

         The third parameter would represent how many bytes to add (or
         subtract, if negative) to the working record size.
         This is an advanced feature called "phantom bytes".

         Note that each call to AdjustRecSize is cumulative. }

  If filerec (F).mode = fmClosed then
    begin
    Reset (dbfile (F));
    DiskError := IoResult;
    end
   else
    DiskError := 0;
  If DiskError = 0 then
    begin
    ReadNextBlock (F, fheader, (succ (totalfields) * sizeof (headertype)) + 1);
    If not IoError and (Size > 0) then
      begin
      recordlimit := fheader [0].numrecs;
      LoadDataBlock (Data, Size, F);
      end;
    end
   else
    begin
    dBASEnew;
    fheader [0].numrecs := recordlimit;
    ReWrite (dbfile (F));
    If not IoError then
      begin
      Close (dbfile (F));
      Reset (dbfile (F));
      If not IoError then
        begin
        WriteNextBlock (F, fheader, fheader [0].headerlen);
        DiskError := IoResult;
        end;
      end;
    end;
end;  { dBASEopen }


  { ─────────────────────────────────────────────────────────────────────── }


procedure dBMXwindow.dBASEwrite (var Data;  var F );
{ use this if you are editing the whole file in memory }
var    i  : word;
begin
  If filerec (F).mode = fmClosed then
    begin
    Reset (dbfile (F));
    If IoError then
      begin
      ReWrite (dbfile (F));
      DiskError := IoResult;
      end;
    end
   else
    DiskError := 0;
  If DiskError = 0 then
    begin
    fheader [0].numrecs := recordlimit;
    WriteNextBlock (F, fheader, fheader [0].headerlen);
    If not IoError then SaveDataBlock (Data, F);
    end;
end;  { dBASEwrite }



  { ─────────────────────────────────────────────────────────────────────── }


procedure dBrowser.EvaluateRecord (RecNum : longint;  Line : word);
{ this virtual method writes a record to the disk after every change }
var  filler : array [0..255] of char;
begin
  If changemade then
    begin
    If fheader [0].numrecs < RecNum + 1 then
      begin
      If fheader [0].numrecs < RecNum then
        begin
        FillChar (filler, sizeof (filler), ' ');
        SeekByte (workfile,
                  fheader [0].headerlen + (fheader [0].numrecs * recordsize));
        While (IoResult = 0) and (fheader [0].numrecs < RecNum) do
          begin
          WriteNextBlock (workfile, filler, recordsize);
          Inc (fheader [0].numrecs);
          end;
        end;
      fheader [0].numrecs := RecNum + 1;
      end;
    SeekByte (workfile, fheader [0].headerlen + (recnum * recordsize));
    WriteNextBlock (workfile, dbfrecord, recordsize);
    changemade := False;
    end;
end;  { EvaluateRecord }


function  dBrowser.DataAt (recnum : longint) : pointer;
{ this virtual method retrieves the record from the file }
begin
  FillChar (dbfrecord, sizeof (dbfrecord), ' ');
  SeekByte (workfile, fheader [0].headerlen + (recnum * recordsize));
  ReadNextBlock (workfile, dbfrecord, recordsize);
  DiskError := IoResult;
  DataAt := addr (dbfrecord);
end;


procedure dBrowser.ZeroizeRecord (var Data );
{ this virtual method zeroizes the record from the file after a ^Y }
begin
  FillChar (dbfrecord, sizeof (dbfrecord), ' ');
  DisplayRecord (Data, linenumber);
  SeekByte (workfile, fheader [0].headerlen + (currentrec * recordsize));
  WriteNextBlock (workfile, dbfrecord, recordsize);
  fieldnum   := 1;
  changemade := False;
end;


  { ─────────────────────────────────────────────────────────────────────── }


procedure dBrowser.dBASEinit (Filename : pathstr);
{ use this if you are editing the file on disk }
var  Data : byte;
begin
  Assign (workfile,Filename);
  dBASEopen (Data, 0, workfile);
end;



  { ─────────────────────────────────────────────────────────────────────── }


procedure dBrowser.dBASEclose;
{ use this if you are editing the file on disk }
begin
  If filerec (workfile).mode <> fmClosed then
    begin
    Seek (workfile, 0);
    WriteNextBlock (workfile, fheader, 32);
    DiskError := IoResult;
    Close (workfile);
    end;
end;



  { ─────────────────────────────────────────────────────────────────────── }



End.